home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gwuada_9.zip / 12A.C < prev    next >
C/C++ Source or Header  |  1993-07-27  |  35KB  |  1,125 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. /* chapter 12 - part a*/
  11. #include "hdr.h"
  12. #include "vars.h"
  13. #include "libhdr.h"
  14. #include "attr.h"
  15. #include "unitsp.h"
  16. #include "errmsgp.h"
  17. #include "miscp.h"
  18. #include "smiscp.h"
  19. #include "setp.h"
  20. #include "libp.h"
  21. #include "dclmapp.h"
  22. #include "nodesp.h"
  23. #include "chapp.h"
  24.  
  25. static Tuple collect_generic_formals(Node);
  26. static void add_implicit_neq(Tuple, Node, Symbol);
  27. static void bind_names(Node);
  28.  
  29. void generic_subprog_spec(Node node)     /*;generic_subprog_spec*/
  30. {
  31.     int        nat, kind, i;
  32.     Node    id_node, generic_part_node, ret_node, formals_list;
  33.     int        f_mode, body_number;
  34.     char    *obj_id;
  35.     Symbol    gen_name, form_name, scope;
  36.     Tuple    gen_list, form_list;
  37.     Tuple    tup;
  38.     Node    formal_node, id_list, m_node, type_node, exp_node, init_node;
  39.     Symbol    type_mark;
  40.     Tuple    f_ids;
  41.     char    *id;
  42.     Fortup    ft1, ft2;
  43.  
  44.     /*
  45.      * Build specifications     of a  generic subprogram. We create  a scope for
  46.      * it, and  define within the  names of generics and  formal  parameters.
  47.      * The signature of the generic subprogram includes the generic parameter
  48.      * list and the formals. These two are unpacked during instantiation.
  49.      */
  50.     if (cdebug2 > 3)
  51.         TO_ERRFILE("AT PROC :  generic_subprog_spec ");
  52.  
  53.     id_node = N_AST1(node);
  54.     generic_part_node = N_AST2(node);
  55.     formals_list = N_AST3(node);
  56.     ret_node = N_AST4(node);
  57.     kind = N_KIND(node);
  58.  
  59.     obj_id = N_VAL(id_node);
  60.     new_compunit("ss", id_node);
  61.  
  62.     if (IS_COMP_UNIT) {
  63.         /* allocate unit number for body, and mark it obsolete */
  64.         body_number = unit_number(strjoin("su", obj_id));
  65.         pUnits[body_number]->libInfo.obsolete = string_ds; /*"$D$"*/
  66.     }
  67.  
  68.     gen_name = find_new(obj_id);
  69.     N_UNQ(id_node) = gen_name;
  70.     DECLARED(gen_name) = dcl_new(0);
  71.     NATURE(gen_name) = na_generic_part;
  72.     formal_decl_tree(gen_name) = (Symbol) formals_list;
  73.     newscope(gen_name);
  74.  
  75.     adasem(generic_part_node);
  76.     gen_list = collect_generic_formals(generic_part_node);
  77.     /*
  78.      * Now declared(gen_name) contains  the generic parameters: types,
  79.      * objects and    subprograms.
  80.      *
  81.      * For the formal parameters, we simply must recognize their names
  82.      * and    types. Type  checking on  initialization  is  repeated    on
  83.      * instantiation.
  84.      */
  85.     NATURE(gen_name) = na_void;        /* To catch premature usage. */
  86.     form_list = tup_new(0);
  87.  
  88.     FORTUP(formal_node =(Node), N_LIST(formals_list), ft1);
  89.         id_list = N_AST1(formal_node);
  90.         m_node = N_AST2(formal_node);
  91.         type_node = N_AST3(formal_node);
  92.         exp_node = N_AST4(formal_node);
  93.         type_mark = find_type(copy_tree(type_node));
  94.  
  95.         if (exp_node != OPT_NODE) {
  96.             adasem(exp_node);
  97.             init_node = copy_tree(exp_node);
  98.             normalize(type_mark, init_node);
  99.         }
  100.         else init_node = OPT_NODE;
  101.         current_node = formal_node;
  102.         f_ids = tup_new(tup_size(N_LIST(id_list)));
  103.         FORTUPI(id_node=(Node), N_LIST(id_list), i, ft2);
  104.             f_ids[i] = N_VAL(id_node);
  105.         ENDFORTUP(ft2);
  106.         f_mode = (int) N_VAL(m_node);
  107.         if (f_mode == 0 ) f_mode = na_in;
  108.  
  109.         FORTUP(id=, f_ids, ft2);
  110.             form_name = find_new(id);
  111.             NATURE(form_name)  = f_mode;
  112.             TYPE_OF(form_name) = type_mark;
  113.             default_expr(form_name) = (Tuple) copy_tree(init_node);
  114.             form_list = tup_with(form_list, (char *) form_name);
  115.         ENDFORTUP(ft2);
  116.  
  117.         if (f_mode != na_in && kind == as_generic_function) {
  118.             errmsg_l(nature_str(f_mode),
  119.               " parameter not allowed for functions", "6.5", formal_node);
  120.         }
  121.         /*  enforce restrictions on usage of out formal parameters given in
  122.           *  LRM 7.4.4
  123.          */
  124.         scope = SCOPE_OF(type_mark);
  125.         nat = NATURE(scope);
  126.         if (f_mode != na_out || is_access(type_mark))
  127.             continue;
  128.         else if (TYPE_OF(type_mark) == symbol_limited_private
  129.             && (nat == na_package_spec || nat == na_generic_package_spec 
  130.             || nat == na_generic_part )
  131.             && !in_private_part(scope)
  132.             && tup_mem((char *)scope, open_scopes) ) {
  133.             /* We    are in the visible  part of  the package that declares
  134.              * the type. Its  full  decl. will  have to be  given with an
  135.              * assignable type.
  136.               */
  137.             misc_type_attributes(type_mark) =  
  138.             (misc_type_attributes(type_mark)) | TA_OUT;
  139.         }
  140.         else if (is_limited_type(type_mark)) {
  141.             errmsg_id("Invalid use of limited type % for out parameter ",
  142.               type_mark, "7.4.4", formal_node);
  143.         }
  144.     ENDFORTUP(ft1);
  145.     /*
  146.      * Save signature of generic object, in the format which the
  147.      * instantiation procedure requires.
  148.      */
  149.     NATURE(gen_name) =
  150.         (kind == as_generic_procedure) ? na_generic_procedure_spec
  151.         : na_generic_function_spec;
  152.     tup = tup_new(4);
  153.     tup[1] = (char *) gen_list;
  154.     tup[2] = (char *) form_list;
  155.     tup[3] = (char *) OPT_NODE;
  156.     tup[4] = (char *) tup_new(0);
  157.     SIGNATURE(gen_name) = tup;
  158.     if (kind == as_generic_function) {
  159.         find_old(ret_node);
  160.         TYPE_OF(gen_name) = N_UNQ(ret_node);
  161.     }
  162.     else {
  163.         TYPE_OF(gen_name) = symbol_none;
  164.     }
  165.     popscope();
  166.  
  167.     save_subprog_info(gen_name);
  168. }
  169.  
  170. void generic_subprog_body(Symbol prog_name, Node node) /*;generic_subprog_body*/
  171. {
  172.     /*
  173.      * Within  its body,  the generic  subprogram  name behaves  as a regular
  174.      * (i.e. non-generic) subprogram. In  particular, it  can be  called (and
  175.      * it cannot be instantiated). Its nature must be set accordingly,  prior
  176.      * to compilation of the body.
  177.      */
  178.     int        new_nat, nat, i;
  179.     Tuple    sig, must_constrain;
  180.     Node    specs_node, decl_node, formals_node;
  181.     char    *spec_name;
  182.     char     *junk;
  183.     Tuple    specs, tup, gen_list, form_list, decscopes, decmaps, body_specs;
  184.     Symbol    generic_sym, g_name;
  185.     Unitdecl    ud;
  186.     Fortup    ft;
  187.  
  188.     /* if module is a generic subprogram body verify that the generic spec 
  189.      * appeared in the same file.
  190.      */
  191.     if (IS_COMP_UNIT) {
  192.         spec_name = strjoin("ss", unit_name_name(unit_name));
  193.         if (!streq(lib_unit_get(spec_name), AISFILENAME))
  194.         errmsg("Separately compiled generics not supported", "none", node);
  195.     }
  196.  
  197.     if (NATURE(prog_name) == na_generic_procedure_spec) {
  198.         new_nat = na_procedure;
  199.         nat = na_generic_procedure; /* Save till end of body. */
  200.     }
  201.     else {
  202.         new_nat = na_function;
  203.         nat = na_generic_function;
  204.     }
  205.  
  206.     /*
  207.      * save and stack the generic symbol for this subprogram to allow the
  208.      * detection of recursive instantiations within the generic body
  209.      */
  210.     generic_sym = sym_new_noseq(na_void);
  211.     sym_copy(generic_sym, prog_name);
  212.     NATURE(generic_sym) = nat;
  213.     current_instances = tup_with(current_instances, (char *)  generic_sym);
  214.  
  215.     NATURE(prog_name) = new_nat;
  216.     /*
  217.      * The signature of a  generic object includes    the generic  part. During
  218.      * compilation of the body, set the signature to contain only the formals
  219.      */
  220.     sig = SIGNATURE(prog_name);
  221.     gen_list = (Tuple) sig[1];
  222.     form_list = (Tuple) sig[2];
  223.     SIGNATURE(prog_name) = (Tuple) form_list;
  224.     OVERLOADS(prog_name) = set_new1((char *) prog_name);
  225.  
  226.     specs_node   = N_AST1(node);
  227.     formals_node = N_AST2(specs_node);
  228.     decl_node    = N_AST2(node);
  229.     newscope(prog_name);
  230.     reprocess_formals(prog_name, formals_node);
  231.     process_subprog_body(node, prog_name);
  232.     force_all_types();
  233.     popscope();
  234.     /*
  235.      * If a generic subprogram parameter is an equality operator, we must
  236.      * construct the body for the corresponding implicitly defined inequality
  237.      */
  238.     add_implicit_neq(gen_list, decl_node, prog_name);
  239.  
  240.     /* Outside of its body, the object is generic again.*/
  241.     NATURE(prog_name) = nat;
  242.     junk = tup_frome(current_instances);
  243.  
  244.     /* collect all generic types whose '$constrain' attribute is set into the
  245.      * tuple must_constrain and save it in the signature of the body
  246.      */
  247.  
  248.     must_constrain = tup_new(0);
  249.     FORTUP(tup=(Tuple), gen_list, ft)
  250.         g_name = (Symbol)tup[1];
  251.         if ((int)misc_type_attributes(g_name) & TA_CONSTRAIN)
  252.             must_constrain = tup_with(must_constrain, (char *)g_name);
  253.     ENDFORTUP(ft)
  254.  
  255.     sig= tup_new(4);
  256.     sig[1] = (char *) gen_list;
  257.     sig[2] = (char *) form_list;
  258.     sig[3] = (char *) node;
  259.     sig[4] = (char *) must_constrain;
  260.     SIGNATURE(prog_name) = sig; /* for instantiation */
  261.     OVERLOADS(prog_name) = (Set) 0;    /* Not a callable object. */
  262.  
  263.     /*
  264.      * If the  corresponding spec was defined in another compilation unit, it
  265.      * must     be updated  accordingly. If the generic is not itself a compila-
  266.      * tion unit, we  find the unit in which it appears, and upda